unit XMLSupport;

{$IFDEF FPC}
{$H+}
{$ENDIF}
interface

uses
  Classes, SysUtils; 

type
  TXMLParamList = class;
  
  { TXMLParamList }

  TXMLParamList=class
  private
    FNames, FValues : TStringList;
    function GetCount: Integer;
    function GetIndexedValues(index: integer): AnsiString;
    function GetNames(index: integer): AnsiString;
    function GetText: AnsiString;
    function GetValues(PropName: AnsiString): AnsiString;
    procedure SetIndexedValues(index: integer; const AValue: AnsiString);
    procedure SetNames(index: integer; const AValue: AnsiString);
    procedure SetText(const AValue: AnsiString);
    procedure SetValues(PropName: AnsiString; const AValue: AnsiString);
  public
    constructor Create;
    destructor Destroy; override;
    
    procedure Clear;
    
    procedure Assign(Source : TXMLParamList);
    
    function IndexOfName(AName:String) : Integer;
    
    property Count : Integer read GetCount;
    property Names[index:integer] : AnsiString read GetNames write SetNames;
    property Values[PropName:AnsiString] : AnsiString read GetValues write SetValues; default;
    property IndexedValues[index:integer] : AnsiString read GetIndexedValues write SetIndexedValues;
    property Text : AnsiString read GetText write SetText;
  end;

function StrToXML(Str:AnsiString): AnsiString;
function XMLToStr(XML:AnsiString): AnsiString;
function XMLCompareStr(S1, S2 : AnsiString) : Boolean; // Pretty quick string compare

implementation
{
  &apos; = '
  &quot; = "
  &gt;   = >
  &lt;   = <
  &amp;  = &
  &#xxx; = Hex Character Encoded
}

function loCase(c : Char) : Char; // Pretty quick character lower case
begin
  case c of
    'A'..'Z' : result := Chr(Ord(c)+32);
  else
    result := c;
  end;
end;

function XMLCompareStr(S1, S2 : AnsiString) : Boolean; // Pretty quick string compare
var
  p1, p2 : PChar;
begin
  p1 := PChar(S1);
  p2 := PChar(S2);
  result := true;
  while (loCase(p1^)=loCase(p2^)) and (p1^<>#0) do
    begin
      inc(p1);
      inc(p2);
    end;
  result := (p1^=p2^) and (p1^=#0);
end;

function StrToXML(Str:AnsiString): AnsiString;
var
  i    : Integer;
  tstr : AnsiString;
  p    : PChar;
begin
  p := PChar(Str);
  SetLength(result, length(Str));
  i := 1;
  while p^ <> #0 do
    begin
      case p^ of
        #39 : begin
                Insert('&apos;', result, i);
                inc(i, 6);
              end;
        '"' : begin
                Insert('&quot;', result, i);
                inc(i, 6);
              end;
        '>' : begin
                Insert('&gt;', result, i);
                inc(i, 4);
              end;
        '<' : begin
                Insert('&lt;', result, i);
                inc(i, 4);
              end;
        '&' : begin
                Insert('&amp;', result, i);
                inc(i, 5);
              end;
        #1..{#8,
        #10..}#31,
        #127..#255 : begin
                       tstr := format('&#%d;', [Ord(p^)]);
                       Insert(tstr, result, i);
                       inc(i, length(tstr));
                     end;
      else
        result[i] := p^;
        inc(i);
      end;
      inc(p);
    end;
  SetLength(result, i-1);
end;

{
  &apos; = '
  &quot; = "
  &gt;   = >
  &lt;   = <
  &amp;  = &
  &#xxx; = Hex Character Encoded
}
function XMLToStr(XML:AnsiString): AnsiString;
var
  l : Integer;
  p : PChar;
  op: String;
  function GetOp : String;
  var
    s : PChar;
  begin
    if p^ = '&' then
      inc(p);
    s := p;
    while (not(p^ in [#0, ';'])) do
      inc(p);
    if p^ = #0 then
      raise Exception.Create('Malformed XML Character Reference tag');
    result := '';
    SetString(result, s, p-s);
  end;
begin
  p := PChar(XML);
  SetLength(result, length(XML));
  l := 0;
  while p^ <> #0 do
    begin
      case p^ of
        '&' : case loCase((p+1)^) of
                '#' : begin
                        op := GetOp;
                        inc(l);
                        result[l] := Chr(StrToIntDef(Copy(op, 2, 5), 32));
                      end;
              else
                op := GetOp;
                // This would be faster if it were moved to a hash system
                if XMLCompareStr(op, 'apos') then
                  begin
                    inc(l);
                    result[l] := #39;
                  end
                else if XMLCompareStr(op, 'quot') then
                  begin
                    inc(l);
                    result[l] := '"';
                  end
                else if XMLCompareStr(op, 'gt') then
                  begin
                    inc(l);
                    result[l] := '>';
                  end
                else if XMLCompareStr(op, 'lt') then
                  begin
                    inc(l);
                    result[l] := '<';
                  end
                else if XMLCompareStr(op, 'amp') then
                  begin
                    inc(l);
                    result[l] := '&';
                  end;
              end;
      else
        inc(l);
        result[l] := p^;
      end;
      inc(p);
    end;
  SetLength(result, l);
end;

{ TXMLParamList }

function TXMLParamList.GetIndexedValues(index: integer): AnsiString;
begin
  result := FValues[index];
end;

function TXMLParamList.GetCount: Integer;
begin
  while FValues.Count < FNames.Count do
    FValues.Add('');
  while FValues.Count > FNames.Count do
    FValues.Delete(FValues.Count-1);
  result := FValues.Count;
end;

function TXMLParamList.GetNames(index: integer): AnsiString;
begin
  result := FNames[index];
end;

function TXMLParamList.GetText: AnsiString;
var
  i : Integer;
begin
  result := '';
  for i := 0 to Count-1 do
    result := result + format('%s="%s" ', [Names[i], IndexedValues[i]]);
  if result <> '' then
    SetLength(result, length(result)-1);
end;

function TXMLParamList.GetValues(PropName: AnsiString): AnsiString;
begin
  result := FValues[FNames.IndexOf(PropName)];
end;

procedure TXMLParamList.SetIndexedValues(index: integer;
  const AValue: AnsiString);
begin
  while FValues.Count < FNames.Count do
    FValues.Add('');
  while FValues.Count > FNames.Count do
    FValues.Delete(FValues.Count-1);
  if trim(AValue) = '' then
    begin
      FValues.Delete(index);
      FNames.Delete(index);
    end
  else
    FValues[index] := AValue;
end;

procedure TXMLParamList.SetNames(index: integer; const AValue: AnsiString);
begin
  if trim(AValue) = '' then
    begin
      FValues.Delete(index);
      FNames.Delete(index);
    end
  else
    FNames[index] := AValue;
end;

procedure TXMLParamList.SetText(const AValue: AnsiString);
var
  RunMode : Byte;
  aName, Val : String;
  Source  : PChar;
begin
  FNames.Clear;
  FValues.Clear;
  Source := PChar(AValue);
  RunMode:= 0;
  aName := '';
  Val := '';
  while Source^<>#0 do
    begin
      case RunMode of
        0 : case Source^ of
              'a'..'z', '_', 'A'..'Z', '0'..'9': aName := aName + Source^;
              '=' : RunMode := 1;
            end;
        1 : if Source^ = '"' then
              RunMode := 2;
        2 : if Source^ <> '"' then
              Val := Val + Source^
            else
              begin
                Values[aName] := Val;
                RunMode := 0;
                Val:='';
                aname:=''; // 2010/6/15 yap
              end;
      end;
      inc(Source);
    end;
end;

procedure TXMLParamList.SetValues(PropName: AnsiString; const AValue: AnsiString);
begin
  while FValues.Count < FNames.Count do
    FValues.Add('');
  while FValues.Count > FNames.Count do
    FValues.Delete(FValues.Count-1);

  if trim(AValue) = '' then
    begin
      if FNames.IndexOf(PropName)>-1 then begin
        FValues.Delete(FNames.IndexOf(PropName));
        FNames.Delete(FNames.IndexOf(PropName));
      end;
    end
  else
    begin
      if FNames.IndexOf(PropName) = -1 then
        begin
          FNames.Add(PropName);
          FValues.Add(AValue);
        end
      else
        FValues[FNames.IndexOf(PropName)] := AValue;
    end;
end;

constructor TXMLParamList.Create;
begin
  FNames := TStringList.Create;
  FValues:= TStringList.Create;
end;

destructor TXMLParamList.Destroy;
begin
  FNames.Free;
  FValues.Free;
  inherited Destroy;
end;

procedure TXMLParamList.Clear;
begin
  FNames.Clear;
  FValues.Clear;
end;

procedure TXMLParamList.Assign(Source: TXMLParamList);
begin
  FNames.Assign(Source.FNames);
  FValues.Assign(Source.FValues);
end;

function TXMLParamList.IndexOfName(AName: String): Integer;
begin
  result := FNames.IndexOf(AName);
end;

end.

